--- Code generation compatible with Java7 *or* Java8 syntax

{--
    ## Concepts

    ### Data types

    Representation of data types doesn't change.


    ### Instances

    Instance functions can now be called directly via the instance
    object, instead of first getting a function pointer.


    ### Higher order functions

    Arguments that have a function type are always strict.


    ### Function arity
    
    The code generator keeps track of the arity of functions.
    For example, in @flip :: (a -> b -> c) -> b -> a -> c@
    it will pass and expect a @Func2@. If you pass a function @f@ with
    arity 1 to @flip@, it will be wrapped in an extra lambda
    @\a\b -> (f a) $ b@.

    When you pass a function @g@ with a higher arity, say 4,
    it will be wrapped in a lambda @(\a\b -> (\x3\x4 -> g a b x3 x4))@.
    
    Fortunately, the compiler will have established type soundness
    during type checking, so that in the first case we know that
    the unary function actually returns another unary function and the
    application @flip g a b@ yields a binary function.


    ### Partial applications
    
    Partial applications like  @flip (-)@ are eta-expanded to  
    @\a\b -> flip (-) a b@. 
    
    A special case of partial application is when a function is not 
    applied at all - like in @fold (+) 0 xs@.


    ### Lazy values
    
    Lazy values will be instances of @java.run.Lazy@, that is in 
    Java8 notation @() -> some code@. Those are not shared.
    
    Shared lazy values (i.e. in @let@ or arguments for constructors) are 
    @new Thunk(() -> value)@.

    Thunk and Lazy know their return type, i.e. they are generic types.


    ## The Four Reasons for Stack Overflow

    ### Tail Calls

    Tail calls are dangerous, unless the tail called function is _tail call safe_.
    A function is _tail call safe_ if one of the following applies:

    - it is a constructor
    - it is a native function
    - it is not recursive and calls only tail call safe functions
    
    In particular, a function passed as argument is not tail call safe.
    
    If the result of a function that is not tail call safe is a (full)
    application of another function, and this function is itself not 
    tail call safe, or a full application of a non tail call safe function
    appears in a strict position, then a Lazy closure must be returned 
    instead of doing the call directly.
    
    Examples:
    
    > even 0 = true
    > even n = odd (n-a)
    > odd  0 = false
    > odd  n = even (n-1)
    
    Both @even@ and @odd@ are clearly unsafe, hence the code for @even@ 
    should be:
    
    > Lazy<java.lang.Boolean> even(int n) {
    >    if (n==0) then return new Thunk(true);
    >    return new Thunk(() -> even(n-1));
    > }
    
    ### @foldr@ Recursion
    
    > foldr f d [] = d
    > foldr f d (x:xs) = x `f` foldr f d xs
    
    If `f` is strict in its right argument, this leads to recursion as deep
    as the length of the list.
    This could be solved when the currently evaluating thread 
-}

module frege.compiler.passes.GenCode where

import Lib.PP(pretty)
import Data.TreeMap(TreeMap, values)
import Data.Graph (stronglyConnectedComponents tsort)

import Compiler.Utilities as U()

import Compiler.types.Global
import Compiler.types.JNames
import Compiler.types.Symbols
import Compiler.types.QNames(QName)
import Compiler.types.Packs(pPreludeBase, pPreludeList)
import Compiler.types.Strictness(Strictness(isStrict))

import Compiler.common.AnnotateG (annoG, annoListG, notNil)
import Compiler.common.JavaName

import Compiler.gen.java.Common
import Compiler.types.AbstractJava
import Compiler.gen.java.Constants(makeConstants)
import Compiler.gen.java.VarCode(varCode)
import Compiler.gen.java.DataCode(dataCode)
import Compiler.gen.java.InstanceCode(classCode, instanceCode, lowerKindSpecialClasses)


pass :: StIO (String, Int)
pass = do
    g   ← getSTT

    let modul = JClass{attr=attrs [JFinal, JPublic], 
                    name = g.gen.main, gvars=[], 
                    extend = fmap (sigmaJT g) g.options.extending, 
                    implement = map (sigmaJT g) g.options.implementing, 
                    defs=[]}
        headline = (pretty 2000 (annoG g modul)).replaceAll ´}´ ""

    --  class my.modul.Name extends ... implements ... {

    -- Note that we don't make a JClass that contains all compiled definitions,
    -- although this would be the natural approach. Instead we compile and
    -- pretty print the definitions individually. This allows us to 
    -- do the pretty printing concurrently maybe later.
    U.println headline

    -- print the embedded Java code 
    reconstruct (g.options.code)

    -- prepare abstract functions of special classes
    oldg ← liftStG lowerKindSpecialClasses
    g ← getSTT
    
    -- classes 
    let classes = [ s | s@SymC {} <- values g.thisTab ]
    liftStG (concat <$> mapM classCode classes)
        >>= liftIO . ppDecls g

    -- instances
    let instances = [ s | s@SymI {} <- values g.thisTab ]
    liftStG (concat <$> mapM instanceCode instances)
        >>= liftIO . ppDecls g

    -- data definitions
    let datas = [ s | s@SymT {} <- values g.thisTab ]
    liftStG (concat <$> mapM dataCode datas)
        >>= liftIO . ppDecls g 

    -- do variables in dependency order, this is so that CAFs refer only to CAFs
    -- whose java initialization occurs earlier
    let vars = [ s | s@SymV {} <- values g.thisTab ]
    liftStG (
            mapSt U.fundep vars 
            >>= mapSt U.findV . concat . tsort 
            >>= mapSt (varCode TreeMap.empty))
        >>= liftIO . ppDecls g . concat 

    -- generate the class for constants
    liftStG makeConstants >>= liftIO . ppDecls g . maybeToList 

    let baseExtras = [
            "final public static<T> TMaybe<T> _toMaybe(T it) {",
            "   return it == null ? TMaybe.DNothing.<T>mk()",
            "                     : TMaybe.DJust.<T>mk(Thunk.<T>lazy(it));",
            "}", 
            ]
    when (g.thisPack == pPreludeBase) (forM_ baseExtras U.println)

    let listExtras = [
            "/*",
            " * The following is used to instantiate kind-lowered contexts to the type",
            " * they are actually used at.",
            " *",
            " * The context is declared at the raw type like ",
            " *     static<A extends Kind.U<A,?>, B> ... method(CListView<A> ctx1, ...)",
            " * ",
            " * This shall work only for the type classes defined here!",
            " */",
            "@SuppressWarnings(\"unchecked\")",
            "public static<A extends Kind.U<A,?>, B> CListEmpty<Kind.U<A, B>> kindedCtx(CListEmpty<A> ctx) {",
            "    return (CListEmpty<Kind.U<A, B>>)(Object) ctx;",
            "}",
            "@SuppressWarnings(\"unchecked\")",
            "public static<A extends Kind.U<A,?>, B> CListMonoid<Kind.U<A, B>> kindedCtx(CListMonoid<A> ctx) {",
            "    return (CListMonoid<Kind.U<A, B>>)(Object) ctx;",
            "}",
            "@SuppressWarnings(\"unchecked\")",
            "public static<A extends Kind.U<A,?>, B> CListSemigroup<Kind.U<A, B>> kindedCtx(CListSemigroup<A> ctx) {",
            "    return (CListSemigroup<Kind.U<A, B>>)(Object) ctx;",
            "}",
            "@SuppressWarnings(\"unchecked\")",
            "public static<A extends Kind.U<A,?>, B> CListView<Kind.U<A, B>> kindedCtx(CListView<A> ctx) {",
            "    return (CListView<Kind.U<A, B>>)(Object) ctx;",
            "}",
            "@SuppressWarnings(\"unchecked\")",
            "public static<A extends Kind.U<A,?>, B> CListSource<Kind.U<A, B>> kindedCtx(CListSource<A> ctx) {",
            "    return (CListSource<Kind.U<A, B>>)(Object) ctx;",
            "}"
            ]
    when (g.thisPack == pPreludeList) (forM_ listExtras U.println)

    -- restore unchanged symtabs
    changeSTT Global.{packages = oldg.packages}

    -- check if we have a main function, and print it
    mapM_ U.println (maybe [] (mainCode g) (haveMain g))

    U.println "}"       -- supply the } that was removed from the headline
    return ("Gen78", 1)


--- Print some declarations stacked
ppDecls :: Global -> [JDecl] → IO ()
ppDecls g decls = do
    PP.prettyIO g.printer 128 . PP.stack . filter notNil . map (annoG g) $ decls
    g.printer.println

--- the java code to run the main function
{--
    > public static void main(final java.lang.String[] argv) {
    >    $type ret =
    >        PreludeBase.TST.performUnsafe($name
    >               ( $list )
    >        );
    >    if ret then System.exit(0) else System.exit(1);   or System.exit(ret&255);  or empty
    > }
-}
mainCode ∷ Global → Symbol → [String]
mainCode g sym = [
        "  public static void main(final java.lang.String[] argv) {",
        "    try {",
        "      frege.run.RunTM.argv = argv;",
        "      " ++ if isInt then "int ret =" else if isBool then "boolean ret =" else "", 
        "        PreludeBase.TST.<" ++ targ ++ ">performUnsafe(" ++ name,
        if sym.depth > 0 then
        "               (" ++ list ++ ").call()"
        else
        "               .call()",           -- evaluate a possibly lazy main
        "          ).call();",              -- evaluate result of performUnsafe
        "      frege.runtime.Runtime.stdout.get().close();",
        "      frege.runtime.Runtime.stderr.get().close();",
        if isInt then
        "        System.exit(ret&255);"
        else if isBool then
        "        System.exit(ret ? 0 : 1);"
        else "",
        "    } finally { " ++ shutdown ++ "(); }",
        "  }"
        ]
    where
        shutdown = "frege.run.Concurrent.shutDownIfExists"; 
        name = (symJavaName g sym).base
        jtype = tauJT g (fst (U.returnType sym.typ.rho))
        isInt 
            | Func{gargs=[a,b]} ← jtype = show b == "Integer"
            | otherwise = false
        isBool
            | Func{gargs=[a,b]} ← jtype = show b == "Boolean"
            | otherwise = false
        targ = if isInt then "Integer" else if isBool then "Boolean" else "Short"
        strict = case sym.strsig of
            Strictness.S (s:_) = isStrict s
            _               = false;
        stol = "PreludeArrays.IListSource_JArray.<String/*<Character>*/>toList(argv)"
        lazy x = "Thunk.lazy(" ++ x ++ ")"
        list = if strict then stol else lazy stol

--- tell if there is a main function in this module
-- haveMain :: Global -> Bool
haveMain g = case Global.findit g (VName g.thisPack "main") of
        Just sym | sym.name.pack == g.thisPack = Just sym
        other = Nothing